From: Félix Sipma Date: Mon, 31 Oct 2016 12:28:53 +0000 (+0000) Subject: Import patat_0.3.3.0.orig.tar.gz X-Git-Tag: archive/raspbian/0.8.2.1-1+rpi1~1^2^2^2~2 X-Git-Url: https://dgit.raspbian.org/%22http:/www.example.com/cgi/%22https:/%22bookmarks://%22%22/%22http:/www.example.com/cgi/%22https:/%22bookmarks:/%22%22?a=commitdiff_plain;h=3421e33554ead922bae8892ddd4bff4471873ff9;p=patat.git Import patat_0.3.3.0.orig.tar.gz [dgit import orig patat_0.3.3.0.orig.tar.gz] --- 3421e33554ead922bae8892ddd4bff4471873ff9 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1a4350c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist +.stack-work diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..f1fac0b --- /dev/null +++ b/.travis.yml @@ -0,0 +1,7 @@ +language: haskell +ghc: '7.8' +sudo: false +install: + - cabal install +script: + - bash test.sh diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..65bba9e --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,24 @@ +# Changelog + +- 0.3.3.0 (2016-10-31) + * Add a `--version` flag. + * Add support for `pandoc-1.18` which includes a new `LineBlock` element. + +- 0.3.2.0 (2016-10-20) + * Keep running even if errors are encountered during reload. + +- 0.3.1.0 (2016-10-18) + * Fix compilation with `lts-6.22`. + +- 0.3.0.0 (2016-10-17) + * Add syntax highlighting support. + * Fixed slide clipping after reload. + +- 0.2.0.0 (2016-10-13) + * Add theming support. + * Fix links display. + * Add support for wrapping. + * Allow org mode as input format. + +- 0.1.0.0 (2016-10-02) + * Upload first version from hotel wifi in Kalaw. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..1f53f40 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/README.md b/README.md new file mode 100644 index 0000000..3cd2820 --- /dev/null +++ b/README.md @@ -0,0 +1,290 @@ +patat +===== + +[![Build Status](https://img.shields.io/travis/jaspervdj/patat.svg)](https://travis-ci.org/jaspervdj/patat) [![Hackage](https://img.shields.io/hackage/v/patat.svg)](https://hackage.haskell.org/package/patat) [![GitHub tag](https://img.shields.io/github/tag/jaspervdj/patat.svg)]() + +`patat` (**P**resentations **A**top **T**he **A**NSI **T**erminal) is a small +tool that allows you to show presentations using only an ANSI terminal. It does +not require `ncurses`. + +Features: + +- Leverages the great [Pandoc] library to support many input formats including + [Literate Haskell]. +- Supports [smart slide splitting](#input-format). +- There is a [live reload](#running) mode. +- [Theming](#theming) support. +- Optionally [re-wrapping](#configuration) text to terminal width with proper + indentation. +- Syntax highlighting for nearly one hundred languages generated from [Kate] + syntax files. +- Written in [Haskell]. + +![screenshot](extra/screenshot.png?raw=true) + +[Kate]: https://kate-editor.org/ +[Haskell]: http://haskell.org/ +[Pandoc]: http://pandoc.org/ + +Table of Contents +----------------- + +- [Installation](#installation) + - [Using stack](#using-stack) + - [Using cabal](#using-cabal) +- [Running](#running) +- [Input format](#input-format) +- [Configuration](#configuration) + - [Theming](#theming) + - [Syntax Highlighting](#syntax-highlighting) +- [Trivia](#trivia) + +Installation +------------ + +You can build from source using `stack install` or `cabal install`. `patat` is +also available from [Hackage]. + +[Hackage]: https://hackage.haskell.org/package/patat + +For people unfamiliar with the Haskell ecosystem, this means you can do either +of the following: + +### Using stack + +1. Install [stack] for your platform. +2. Clone this repository. +3. Run `stack setup` (if you're running stack for the first time) and + `stack install`. +4. Make sure `$HOME/.local/bin` is in your `$PATH`. + +[stack]: https://docs.haskellstack.org/en/stable/README/ + +### Using cabal + +1. Install [cabal] for your platform. +2. Run `cabal install patat`. +3. Make sure `$HOME/.cabal/bin` is in your `$PATH`. + +[cabal]: https://www.haskell.org/cabal/ + +Running +------- + + patat [--watch] presentation.md + +Controls: + +- **Next slide**: `space`, `enter`, `l`, `→` +- **Previous slide**: `backspace`, `h`, `←` +- **Go forward 10 slides**: `j`, `↓` +- **Go backward 10 slides**: `k`, `↑` +- **First slide**: `0` +- **Last slide**: `G` +- **Reload file**: `r` +- **Quit**: `q` + +The `r` key is very useful since it allows you to preview your slides while you +are writing them. You can also use this to fix artifacts when the terminal is +resized. + +If you provide the `--watch` flag, `patat` will watch the presentation file for +changes and reload automatically. This is very useful when you are writing the +presentation. + +Input format +------------ + +The input format can be anything that Pandoc supports. Plain markdown is +usually the most simple solution: + + --- + title: This is my presentation + author: Jane Doe + ... + + # This is a slide + + Slide contents. Yay. + + --- + + # Important title + + Things I like: + + - Markdown + - Haskell + - Pandoc + +Horizontal rulers (`---`) are used to split slides. + +However, if you prefer not use these since they are a bit intrusive in the +markdown, you can also start every slide with an `h1` header. In that case, the +file should not contain a single horizontal ruler. + +This means the following document is equivalent: + + --- + title: This is my presentation + author: Jane Doe + ... + + # This is a slide + + Slide contents. Yay. + + # Important title + + Things I like: + + - Markdown + - Haskell + - Pandoc + +Configuration +------------- + +`patat` is fairly configurable. The configuration is done using [YAML]. There +are two places where you can put your configuration: + +1. In the presentation file itself, using the [Pandoc metadata header]. +2. In `$HOME/.patat.yaml` + +[YAML]: http://yaml.org/ +[Pandoc metadata header]: http://pandoc.org/MANUAL.html#extension-yaml_metadata_block + +For example, we can turn on line wrapping by using the following file: + + --- + title: Presentation with wrapping + author: John Doe + patat: + wrap: true + ... + + This is a split + line which should + be re-wrapped. + +Or we can use a normal presentation and have the following `$HOME/.patat.yaml`: + + wrap: true + +### Theming + +Colors and other properties can also be changed using this configuration. For +example, we can have: + + --- + author: 'Jasper Van der Jeugt' + title: 'This is a test' + patat: + wrap: true + theme: + emph: [vividBlue, onVividBlack, bold] + imageTarget: [onDullWhite, vividRed] + ... + + # This is a presentation + + This is _emph_ text. + + ![Hello](foo.png) + +The properties that can be given a list of styles are: + +- `borders` +- `header` +- `codeBlock` +- `bulletList` +- `orderedList` +- `blockQuote` +- `definitionTerm` +- `definitionList` +- `tableHeader` +- `tableSeparator` +- `emph` +- `strong` +- `code` +- `linkText` +- `linkTarget` +- `strikeout` +- `quoted` +- `math` +- `imageText` +- `imageTarget` + +The accepted styles are: + +- `bold` +- `dullBlack` +- `dullBlue` +- `dullCyan` +- `dullGreen` +- `dullMagenta` +- `dullRed` +- `dullWhite` +- `dullYellow` +- `onDullBlack` +- `onDullBlue` +- `onDullCyan` +- `onDullGreen` +- `onDullMagenta` +- `onDullRed` +- `onDullWhite` +- `onDullYellow` +- `onVividBlack` +- `onVividBlue` +- `onVividCyan` +- `onVividGreen` +- `onVividMagenta` +- `onVividRed` +- `onVividWhite` +- `onVividYellow` +- `underline` +- `vividBlack` +- `vividBlue` +- `vividCyan` +- `vividGreen` +- `vividMagenta` +- `vividRed` +- `vividWhite` +- `vividYellow` + +### Syntax Highlighting + +As part of theming, syntax highlighting is also configurable. This can be +configured like this: + + --- + patat: + theme: + syntaxHighlighting: + decVal: [bold, onDullRed] + ... + + ... + +`decVal` refers to "decimal values". This is known as a "token type". For a +full list of token types, see [this list] -- the names are derived from there in +an obvious way. + +[this list]: https://hackage.haskell.org/package/highlighting-kate-0.6.3/docs/Text-Highlighting-Kate-Types.html#t:TokenType + +Trivia +------ + +_"Patat"_ is the Flemish word for a simple potato. Dutch people also use it to +refer to French Fries but I don't really do that -- in Belgium we just call +fries _"Frieten"_. + +The idea of `patat` is largely based upon [MDP] which is in turn based upon +[VTMC]. I wanted to write a clone using Pandoc because I ran into a markdown +parsing bug in MDP which I could not work around. A second reason to do a +Pandoc-based tool was that I would be able to use [Literate Haskell] as well. +Lastly, I also prefer not to install Node.js on my machine if I can avoid it. + +[MDP]: https://github.com/visit1985/mdp +[VTMC]: https://github.com/jclulow/vtmc +[Literate Haskell]: https://wiki.haskell.org/Literate_programming diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..35e9936 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +patat (0.3.2.0-1) unstable; urgency=medium + + * Initial release (Closes: #840738) + + -- Félix Sipma Tue, 25 Oct 2016 23:46:09 +0200 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..f599e28 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +10 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..c1523d1 --- /dev/null +++ b/debian/control @@ -0,0 +1,40 @@ +Source: patat +Maintainer: Félix Sipma +Priority: extra +Section: haskell +Build-Depends: debhelper (>= 10), + ghc, + libghc-aeson-dev (>= 0.11), + libghc-aeson-dev (<< 1.1), + libghc-ansi-terminal-dev (>= 0.6), + libghc-ansi-terminal-dev (<< 0.7), + libghc-ansi-wl-pprint-dev (>= 0.6), + libghc-ansi-wl-pprint-dev (<< 0.7), + libghc-highlighting-kate-dev (>= 0.6), + libghc-highlighting-kate-dev (<< 0.7), + libghc-mtl-dev (>= 2.2), + libghc-mtl-dev (<< 2.3), + libghc-optparse-applicative-dev (>= 0.12), + libghc-optparse-applicative-dev (<< 0.14), + libghc-pandoc-dev (>= 1.17), + libghc-pandoc-dev (<< 1.18), + libghc-terminal-size-dev (>= 0.3), + libghc-terminal-size-dev (<< 0.4), + libghc-text-dev (>= 1.2), + libghc-text-dev (<< 1.3), + libghc-yaml-dev (>= 0.7), + libghc-yaml-dev (<< 0.9), + pandoc +Standards-Version: 3.9.8 +Homepage: http://github.com/jaspervdj/patat +Vcs-Git: https://git.gueux.org/patat.git +Vcs-Browser: https://git.gueux.org/?p=patat.git;a=summary + +Package: patat +Architecture: any +Section: misc +Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends} +Description: Terminal-based presentations using Pandoc + patat (*P*resentations *A*top *T*he *A*NSI *T*erminal) is a small tool that + allows you to show presentations using only an ANSI terminal. It does not + require `ncurses`. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..f9fa260 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,29 @@ +Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ +Upstream-Name: patat +Upstream-Contact: Jasper Van der Jeugt +Source: https://hackage.haskell.org/package/patat + +Files: * +Copyright: 2016 Jasper Van der Jeugt +License: GPL-2 + +Files: debian/* +Copyright: 2016 Félix Sipma +License: GPL-2 + +License: GPL-2 + This package is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License version 2 as + published by the Free Software Foundation. + . + This package is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + . + You should have received a copy of the GNU General Public License + along with this package; if not, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + . + On Debian systems, the complete text of the GNU General Public License version + 2 can be found in `/usr/share/common-licenses/GPL-2'. diff --git a/debian/docs b/debian/docs new file mode 100644 index 0000000..b43bf86 --- /dev/null +++ b/debian/docs @@ -0,0 +1 @@ +README.md diff --git a/debian/lintian-overrides b/debian/lintian-overrides new file mode 100644 index 0000000..172c637 --- /dev/null +++ b/debian/lintian-overrides @@ -0,0 +1,2 @@ +# standard override for Haskell binary packages +binary-or-shlib-defines-rpath diff --git a/debian/patat.examples b/debian/patat.examples new file mode 100644 index 0000000..56ab4af --- /dev/null +++ b/debian/patat.examples @@ -0,0 +1 @@ +extra/screenshot.png diff --git a/debian/patat.install b/debian/patat.install new file mode 100644 index 0000000..3d405a1 --- /dev/null +++ b/debian/patat.install @@ -0,0 +1 @@ +dist/build/patat/patat usr/bin diff --git a/debian/patat.manpages b/debian/patat.manpages new file mode 100644 index 0000000..fdcdd4e --- /dev/null +++ b/debian/patat.manpages @@ -0,0 +1 @@ +debian/patat.1 diff --git a/debian/patat.md b/debian/patat.md new file mode 100644 index 0000000..34717ee --- /dev/null +++ b/debian/patat.md @@ -0,0 +1,48 @@ +% patat(1) +% [Jasper Van der Jeugt](mailto:m@jaspervdj.be) +% October 2016 + +Name +==== + +patat - Terminal-based presentations using Pandoc + +Synopsis +======== + +`patat` [*OPTION* ...] [*FILENAME*] + +Description +=========== + +`patat` (**P**resentations **A**top **T**he **A**NSI **T**erminal) is a small +tool that allows you to show presentations using only an ANSI terminal. It +does not require `ncurses`. + +Options +======= + +`-h`,`--help` + +: Show this help text + +`FILENAME` + +: Input file + +`-f`,`--force` + +: Force ANSI terminal + +`-d`,`--dump` + +: Just dump all slides and exit + +`-w`,`--watch` + +: Watch file for changes + +`--version` + +: Display version info and exit + diff --git a/debian/patches/0001-Debianize-README.md.patch b/debian/patches/0001-Debianize-README.md.patch new file mode 100644 index 0000000..db4b94d --- /dev/null +++ b/debian/patches/0001-Debianize-README.md.patch @@ -0,0 +1,78 @@ +From: =?utf-8?q?F=C3=A9lix_Sipma?= +Date: Thu, 20 Oct 2016 15:09:42 +0200 +Subject: Debianize README.md + +- remove installation instructions and CI links +- modify link to screenshot file +--- + README.md | 36 +----------------------------------- + 1 file changed, 1 insertion(+), 35 deletions(-) + +diff --git a/README.md b/README.md +index 3cd2820..3dfcdf6 100644 +--- a/README.md ++++ b/README.md +@@ -1,8 +1,6 @@ + patat + ===== + +-[![Build Status](https://img.shields.io/travis/jaspervdj/patat.svg)](https://travis-ci.org/jaspervdj/patat) [![Hackage](https://img.shields.io/hackage/v/patat.svg)](https://hackage.haskell.org/package/patat) [![GitHub tag](https://img.shields.io/github/tag/jaspervdj/patat.svg)]() +- + `patat` (**P**resentations **A**top **T**he **A**NSI **T**erminal) is a small + tool that allows you to show presentations using only an ANSI terminal. It does + not require `ncurses`. +@@ -20,7 +18,7 @@ Features: + syntax files. + - Written in [Haskell]. + +-![screenshot](extra/screenshot.png?raw=true) ++![screenshot](examples/screenshot.png?raw=true) + + [Kate]: https://kate-editor.org/ + [Haskell]: http://haskell.org/ +@@ -29,9 +27,6 @@ Features: + Table of Contents + ----------------- + +-- [Installation](#installation) +- - [Using stack](#using-stack) +- - [Using cabal](#using-cabal) + - [Running](#running) + - [Input format](#input-format) + - [Configuration](#configuration) +@@ -39,35 +34,6 @@ Table of Contents + - [Syntax Highlighting](#syntax-highlighting) + - [Trivia](#trivia) + +-Installation +------------- +- +-You can build from source using `stack install` or `cabal install`. `patat` is +-also available from [Hackage]. +- +-[Hackage]: https://hackage.haskell.org/package/patat +- +-For people unfamiliar with the Haskell ecosystem, this means you can do either +-of the following: +- +-### Using stack +- +-1. Install [stack] for your platform. +-2. Clone this repository. +-3. Run `stack setup` (if you're running stack for the first time) and +- `stack install`. +-4. Make sure `$HOME/.local/bin` is in your `$PATH`. +- +-[stack]: https://docs.haskellstack.org/en/stable/README/ +- +-### Using cabal +- +-1. Install [cabal] for your platform. +-2. Run `cabal install patat`. +-3. Make sure `$HOME/.cabal/bin` is in your `$PATH`. +- +-[cabal]: https://www.haskell.org/cabal/ +- + Running + ------- + diff --git a/debian/patches/0002-add-version.patch b/debian/patches/0002-add-version.patch new file mode 100644 index 0000000..32564a2 --- /dev/null +++ b/debian/patches/0002-add-version.patch @@ -0,0 +1,95 @@ +From: =?utf-8?q?F=C3=A9lix_Sipma?= +Date: Tue, 25 Oct 2016 14:47:45 +0200 +Subject: add --version + +--- + src/Main.hs | 32 ++++++++++++++++++++++++++------ + 1 file changed, 26 insertions(+), 6 deletions(-) + +diff --git a/src/Main.hs b/src/Main.hs +index 6527cbd..fa434da 100644 +--- a/src/Main.hs ++++ b/src/Main.hs +@@ -10,7 +10,7 @@ import Control.Applicative ((<$>), (<*>)) + import Control.Concurrent (forkIO, threadDelay) + import qualified Control.Concurrent.Chan as Chan + import Control.Monad (forever, unless, when) +-import Data.Monoid ((<>)) ++import Data.Monoid (mempty, (<>)) + import Data.Time (UTCTime) + import Data.Version (showVersion) + import qualified Options.Applicative as OA +@@ -19,7 +19,7 @@ import qualified Paths_patat + import qualified System.Console.ANSI as Ansi + import System.Directory (doesFileExist, + getModificationTime) +-import System.Exit (exitFailure) ++import System.Exit (exitFailure, exitSuccess) + import qualified System.IO as IO + import qualified Text.PrettyPrint.ANSI.Leijen as PP + import Prelude +@@ -27,17 +27,18 @@ import Prelude + + -------------------------------------------------------------------------------- + data Options = Options +- { oFilePath :: !FilePath ++ { oFilePath :: !(Maybe FilePath) + , oForce :: !Bool + , oDump :: !Bool + , oWatch :: !Bool ++ , oVersion :: !Bool + } deriving (Show) + + + -------------------------------------------------------------------------------- + parseOptions :: OA.Parser Options + parseOptions = Options +- <$> (OA.strArgument $ ++ <$> (OA.optional $ OA.strArgument $ + OA.metavar "FILENAME" <> + OA.help "Input file") + <*> (OA.switch $ +@@ -54,6 +55,10 @@ parseOptions = Options + OA.long "watch" <> + OA.short 'w' <> + OA.help "Watch file for changes") ++ <*> (OA.switch $ ++ OA.long "version" <> ++ OA.help "Display version info and exit" <> ++ OA.hidden) + + + -------------------------------------------------------------------------------- +@@ -79,6 +84,11 @@ parserInfo = OA.info (OA.helper <*> parseOptions) $ + + + -------------------------------------------------------------------------------- ++parserPrefs :: OA.ParserPrefs ++parserPrefs = OA.prefs OA.showHelpOnError ++ ++ ++-------------------------------------------------------------------------------- + errorAndExit :: [String] -> IO a + errorAndExit msg = do + mapM_ (IO.hPutStrLn IO.stderr) msg +@@ -98,8 +108,18 @@ assertAnsiFeatures = do + -------------------------------------------------------------------------------- + main :: IO () + main = do +- options <- OA.customExecParser (OA.prefs OA.showHelpOnError) parserInfo +- errOrPres <- readPresentation (oFilePath options) ++ options <- OA.customExecParser parserPrefs parserInfo ++ ++ when (oVersion options) $ do ++ putStrLn (showVersion Paths_patat.version) ++ exitSuccess ++ ++ filePath <- case oFilePath options of ++ Just fp -> return fp ++ Nothing -> OA.handleParseResult $ OA.Failure $ ++ OA.parserFailure parserPrefs parserInfo OA.ShowHelpText mempty ++ ++ errOrPres <- readPresentation filePath + pres <- either (errorAndExit . return) return errOrPres + + unless (oForce options) assertAnsiFeatures diff --git a/debian/patches/series b/debian/patches/series new file mode 100644 index 0000000..3ade4dc --- /dev/null +++ b/debian/patches/series @@ -0,0 +1,2 @@ +0001-Debianize-README.md.patch +0002-add-version.patch diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..a640af6 --- /dev/null +++ b/debian/rules @@ -0,0 +1,26 @@ +#!/usr/bin/make -f + +# these rules originally written by Joey Hess for hothasktags package + +%: + dh $@ + +override_dh_auto_configure: + ghc --make Setup + ./Setup configure + +override_dh_auto_build: + pandoc -sS debian/patat.md -o debian/patat.1 + ./Setup build + +override_dh_auto_clean: + if [ -x Setup ]; then ./Setup clean; fi + rm -f Setup Setup.o Setup.hi debian/patat.1 + +override_dh_auto_test: + PATH="$(PATH):dist/build/patat/" bash test.sh + +override_dh_strip: + # GHC cannot produce debugging symbols so the -dbgsym package + # ends up empty, so disable generating it + dh_strip --no-automatic-dbgsym diff --git a/debian/source/format b/debian/source/format new file mode 100644 index 0000000..163aaf8 --- /dev/null +++ b/debian/source/format @@ -0,0 +1 @@ +3.0 (quilt) diff --git a/debian/watch b/debian/watch new file mode 100644 index 0000000..95dbdf1 --- /dev/null +++ b/debian/watch @@ -0,0 +1,4 @@ +version=3 + +opts=filenamemangle=s/.+\/v?(\d\S*)\.tar\.gz/patat-$1\.tar\.gz/ \ + https://github.com/jaspervdj/patat/tags .*/v?(\d\S*)\.tar\.gz diff --git a/extra/screenshot.png b/extra/screenshot.png new file mode 100644 index 0000000..afc45b0 Binary files /dev/null and b/extra/screenshot.png differ diff --git a/patat.cabal b/patat.cabal new file mode 100644 index 0000000..35bcadc --- /dev/null +++ b/patat.cabal @@ -0,0 +1,57 @@ +Name: patat +Version: 0.3.3.0 +Synopsis: Terminal-based presentations using Pandoc +Description: Terminal-based presentations using Pandoc +License: GPL-2 +License-file: LICENSE +Author: Jasper Van der Jeugt +Maintainer: Jasper Van der Jeugt +Homepage: http://github.com/jaspervdj/patat +Copyright: 2016 Jasper Van der Jeugt +Category: Text +Build-type: Simple +Extra-source-files: CHANGELOG.md +Cabal-version: >=1.10 + +Source-repository head + Type: git + Location: git://github.com/jaspervdj/patat.git + +Executable patat + Main-is: Main.hs + Ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N" + Hs-source-dirs: src + Default-language: Haskell2010 + + Build-depends: + aeson >= 0.9 && < 1.1, + ansi-terminal >= 0.6 && < 0.7, + ansi-wl-pprint >= 0.6 && < 0.7, + base >= 4.6 && < 4.10, + bytestring >= 0.10 && < 0.11, + containers >= 0.5 && < 0.6, + directory >= 1.2 && < 1.3, + filepath >= 1.4 && < 1.5, + highlighting-kate >= 0.6 && < 0.7, + mtl >= 2.2 && < 2.3, + optparse-applicative >= 0.12 && < 0.14, + pandoc >= 1.16 && < 1.19, + terminal-size >= 0.3 && < 0.4, + text >= 1.2 && < 1.3, + time >= 1.4 && < 1.7, + yaml >= 0.7 && < 0.9 + + Other-modules: + Data.Aeson.Extended + Data.Aeson.TH.Extended + Data.Data.Extended + Patat.Presentation + Patat.Presentation.Display + Patat.Presentation.Display.CodeBlock + Patat.Presentation.Display.Table + Patat.Presentation.Interactive + Patat.Presentation.Internal + Patat.Presentation.Read + Patat.PrettyPrint + Patat.Theme + Text.Pandoc.Extended diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs new file mode 100644 index 0000000..9b95cec --- /dev/null +++ b/src/Data/Aeson/Extended.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Aeson.Extended + ( module Data.Aeson + + , FlexibleNum (..) + ) where + +import Control.Applicative ((<$>)) +import Data.Aeson +import qualified Data.Text as T +import Text.Read (readMaybe) +import Prelude + +-- | This can be parsed from a JSON string in addition to a JSON number. +newtype FlexibleNum a = FlexibleNum {unFlexibleNum :: a} + deriving (Show, ToJSON) + +instance (FromJSON a, Read a) => FromJSON (FlexibleNum a) where + parseJSON (String str) = case readMaybe (T.unpack str) of + Nothing -> fail $ "Could not parse " ++ T.unpack str ++ " as a number" + Just x -> return (FlexibleNum x) + parseJSON val = FlexibleNum <$> parseJSON val diff --git a/src/Data/Aeson/TH/Extended.hs b/src/Data/Aeson/TH/Extended.hs new file mode 100644 index 0000000..0fa5487 --- /dev/null +++ b/src/Data/Aeson/TH/Extended.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +module Data.Aeson.TH.Extended + ( module Data.Aeson.TH + , dropPrefixOptions + ) where + + +-------------------------------------------------------------------------------- +import Data.Aeson.TH +import Data.Char (isUpper, toLower) + + +-------------------------------------------------------------------------------- +dropPrefixOptions :: Options +dropPrefixOptions = defaultOptions + { fieldLabelModifier = dropPrefix + } + where + dropPrefix str = case break isUpper str of + (_, (y : ys)) -> toLower y : ys + _ -> str diff --git a/src/Data/Data/Extended.hs b/src/Data/Data/Extended.hs new file mode 100644 index 0000000..636591e --- /dev/null +++ b/src/Data/Data/Extended.hs @@ -0,0 +1,23 @@ +module Data.Data.Extended + ( module Data.Data + + , grecQ + , grecT + ) where + +import Data.Data + +-- | Recursively find all values of a certain type. +grecQ :: (Data a, Data b) => a -> [b] +grecQ = concat . gmapQ (\x -> maybe id (:) (cast x) $ grecQ x) + +-- | Recursively apply an update to a certain type. +grecT :: (Data a, Data b) => (a -> a) -> b -> b +grecT f x = gmapT (grecT f) (castMap f x) + +castMap :: (Typeable a, Typeable b) => (a -> a) -> b -> b +castMap f x = case cast x of + Nothing -> x + Just y -> case cast (f y) of + Nothing -> x + Just z -> z diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..fa434da --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,170 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent (forkIO, threadDelay) +import qualified Control.Concurrent.Chan as Chan +import Control.Monad (forever, unless, when) +import Data.Monoid (mempty, (<>)) +import Data.Time (UTCTime) +import Data.Version (showVersion) +import qualified Options.Applicative as OA +import Patat.Presentation +import qualified Paths_patat +import qualified System.Console.ANSI as Ansi +import System.Directory (doesFileExist, + getModificationTime) +import System.Exit (exitFailure, exitSuccess) +import qualified System.IO as IO +import qualified Text.PrettyPrint.ANSI.Leijen as PP +import Prelude + + +-------------------------------------------------------------------------------- +data Options = Options + { oFilePath :: !(Maybe FilePath) + , oForce :: !Bool + , oDump :: !Bool + , oWatch :: !Bool + , oVersion :: !Bool + } deriving (Show) + + +-------------------------------------------------------------------------------- +parseOptions :: OA.Parser Options +parseOptions = Options + <$> (OA.optional $ OA.strArgument $ + OA.metavar "FILENAME" <> + OA.help "Input file") + <*> (OA.switch $ + OA.long "force" <> + OA.short 'f' <> + OA.help "Force ANSI terminal" <> + OA.hidden) + <*> (OA.switch $ + OA.long "dump" <> + OA.short 'd' <> + OA.help "Just dump all slides and exit" <> + OA.hidden) + <*> (OA.switch $ + OA.long "watch" <> + OA.short 'w' <> + OA.help "Watch file for changes") + <*> (OA.switch $ + OA.long "version" <> + OA.help "Display version info and exit" <> + OA.hidden) + + +-------------------------------------------------------------------------------- +parserInfo :: OA.ParserInfo Options +parserInfo = OA.info (OA.helper <*> parseOptions) $ + OA.fullDesc <> + OA.header ("patat v" <> showVersion Paths_patat.version) <> + OA.progDescDoc (Just desc) + where + desc = PP.vcat + [ "Terminal-based presentations using Pandoc" + , "" + , "Controls:" + , "- Next slide: space, enter, l, right" + , "- Previous slide: backspace, h, left" + , "- Go forward 10 slides: j, down" + , "- Go backward 10 slides: k, up" + , "- First slide: 0" + , "- Last slide: G" + , "- Reload file: r" + , "- Quit: q" + ] + + +-------------------------------------------------------------------------------- +parserPrefs :: OA.ParserPrefs +parserPrefs = OA.prefs OA.showHelpOnError + + +-------------------------------------------------------------------------------- +errorAndExit :: [String] -> IO a +errorAndExit msg = do + mapM_ (IO.hPutStrLn IO.stderr) msg + exitFailure + + +-------------------------------------------------------------------------------- +assertAnsiFeatures :: IO () +assertAnsiFeatures = do + supports <- Ansi.hSupportsANSI IO.stdout + unless supports $ errorAndExit + [ "It looks like your terminal does not support ANSI codes." + , "If you still want to run the presentation, use `--force`." + ] + + +-------------------------------------------------------------------------------- +main :: IO () +main = do + options <- OA.customExecParser parserPrefs parserInfo + + when (oVersion options) $ do + putStrLn (showVersion Paths_patat.version) + exitSuccess + + filePath <- case oFilePath options of + Just fp -> return fp + Nothing -> OA.handleParseResult $ OA.Failure $ + OA.parserFailure parserPrefs parserInfo OA.ShowHelpText mempty + + errOrPres <- readPresentation filePath + pres <- either (errorAndExit . return) return errOrPres + + unless (oForce options) assertAnsiFeatures + + if oDump options + then dumpPresentation pres + else interactiveLoop options pres + where + interactiveLoop :: Options -> Presentation -> IO () + interactiveLoop options pres0 = do + IO.hSetBuffering IO.stdin IO.NoBuffering + commandChan <- Chan.newChan + + _ <- forkIO $ forever $ + readPresentationCommand >>= Chan.writeChan commandChan + + mtime0 <- getModificationTime (pFilePath pres0) + when (oWatch options) $ do + _ <- forkIO $ watcher commandChan (pFilePath pres0) mtime0 + return () + + let loop :: Presentation -> Maybe String -> IO () + loop pres mbError = do + case mbError of + Nothing -> displayPresentation pres + Just err -> displayPresentationError pres err + + c <- Chan.readChan commandChan + update <- updatePresentation c pres + case update of + ExitedPresentation -> return () + UpdatedPresentation pres' -> loop pres' Nothing + ErroredPresentation err -> loop pres (Just err) + + loop pres0 Nothing + + +-------------------------------------------------------------------------------- +watcher :: Chan.Chan PresentationCommand -> FilePath -> UTCTime -> IO a +watcher chan filePath mtime0 = do + -- The extra exists check helps because some editors temporarily make the + -- file dissapear while writing. + exists <- doesFileExist filePath + mtime1 <- if exists then getModificationTime filePath else return mtime0 + + when (mtime1 > mtime0) $ Chan.writeChan chan Reload + threadDelay (200 * 1000) + watcher chan filePath mtime1 diff --git a/src/Patat/Presentation.hs b/src/Patat/Presentation.hs new file mode 100644 index 0000000..8da5a30 --- /dev/null +++ b/src/Patat/Presentation.hs @@ -0,0 +1,20 @@ +module Patat.Presentation + ( PresentationSettings (..) + , defaultPresentationSettings + + , Presentation (..) + , readPresentation + , displayPresentation + , displayPresentationError + , dumpPresentation + + , PresentationCommand (..) + , readPresentationCommand + , UpdatedPresentation (..) + , updatePresentation + ) where + +import Patat.Presentation.Display +import Patat.Presentation.Interactive +import Patat.Presentation.Internal +import Patat.Presentation.Read diff --git a/src/Patat/Presentation/Display.hs b/src/Patat/Presentation/Display.hs new file mode 100644 index 0000000..99762e3 --- /dev/null +++ b/src/Patat/Presentation/Display.hs @@ -0,0 +1,311 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Display + ( displayPresentation + , displayPresentationError + , dumpPresentation + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Monad (mplus, unless) +import qualified Data.Aeson.Extended as A +import Data.Data.Extended (grecQ) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Monoid (mconcat, mempty, (<>)) +import qualified Data.Text as T +import Patat.Presentation.Display.CodeBlock +import Patat.Presentation.Display.Table +import Patat.Presentation.Internal +import Patat.PrettyPrint ((<$$>), (<+>)) +import qualified Patat.PrettyPrint as PP +import Patat.Theme (Theme (..)) +import qualified Patat.Theme as Theme +import qualified System.Console.ANSI as Ansi +import qualified System.Console.Terminal.Size as Terminal +import qualified Text.Pandoc.Extended as Pandoc +import Prelude + + +-------------------------------------------------------------------------------- +-- | Display something within the presentation borders that draw the title and +-- the active slide number and so on. +displayWithBorders :: Presentation -> (Theme -> PP.Doc) -> IO () +displayWithBorders Presentation {..} f = do + Ansi.clearScreen + Ansi.setCursorPosition 0 0 + + -- Get terminal width/title + mbWindow <- Terminal.size + let columns = fromMaybe 72 $ + (A.unFlexibleNum <$> psColumns pSettings) `mplus` + (Terminal.width <$> mbWindow) + rows = fromMaybe 24 $ + (A.unFlexibleNum <$> psRows pSettings) `mplus` + (Terminal.height <$> mbWindow) + + let settings = pSettings {psColumns = Just $ A.FlexibleNum columns} + theme = fromMaybe Theme.defaultTheme (psTheme settings) + title = PP.toString (prettyInlines theme pTitle) + titleWidth = length title + titleOffset = (columns - titleWidth) `div` 2 + borders = themed (themeBorders theme) + + unless (null title) $ do + Ansi.setCursorColumn titleOffset + PP.putDoc $ borders $ PP.string title + putStrLn "" + putStrLn "" + + PP.putDoc $ withWrapSettings settings $ f theme + putStrLn "" + + let active = show (pActiveSlide + 1) ++ " / " ++ show (length pSlides) + activeWidth = length active + + Ansi.setCursorPosition (rows - 2) 0 + PP.putDoc $ " " <> borders (prettyInlines theme pAuthor) + Ansi.setCursorColumn (columns - activeWidth - 1) + PP.putDoc $ borders $ PP.string active + putStrLn "" + + +-------------------------------------------------------------------------------- +displayPresentation :: Presentation -> IO () +displayPresentation pres@Presentation {..} = displayWithBorders pres $ \theme -> + let slide = case drop pActiveSlide pSlides of + [] -> mempty + (s : _) -> s in + + prettySlide theme slide + + +-------------------------------------------------------------------------------- +-- | Displays an error in the place of the presentation. This is useful if we +-- want to display an error but keep the presentation running. +displayPresentationError :: Presentation -> String -> IO () +displayPresentationError pres err = displayWithBorders pres $ \Theme {..} -> + themed themeStrong "Error occurred in the presentation:" <$$> + "" <$$> + (PP.string err) + + +-------------------------------------------------------------------------------- +dumpPresentation :: Presentation -> IO () +dumpPresentation pres = + let theme = fromMaybe Theme.defaultTheme (psTheme $ pSettings pres) in + PP.putDoc $ withWrapSettings (pSettings pres) $ + PP.vcat $ intersperse "----------" $ + map (prettySlide theme) $ pSlides pres + + +-------------------------------------------------------------------------------- +withWrapSettings :: PresentationSettings -> PP.Doc -> PP.Doc +withWrapSettings ps = case (psWrap ps, psColumns ps) of + (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just col) + _ -> id + + +-------------------------------------------------------------------------------- +prettySlide :: Theme -> Slide -> PP.Doc +prettySlide theme slide@(Slide blocks) = + prettyBlocks theme blocks <> + case prettyReferences theme slide of + [] -> mempty + refs -> PP.hardline <> PP.vcat refs + + +-------------------------------------------------------------------------------- +prettyBlock :: Theme -> Pandoc.Block -> PP.Doc + +prettyBlock theme (Pandoc.Plain inlines) = prettyInlines theme inlines + +prettyBlock theme (Pandoc.Para inlines) = + prettyInlines theme inlines <> PP.hardline + +prettyBlock theme@Theme {..} (Pandoc.Header i _ inlines) = + themed themeHeader (PP.string (replicate i '#') <+> prettyInlines theme inlines) <> + PP.hardline + +prettyBlock theme (Pandoc.CodeBlock (_, classes, _) txt) = + prettyCodeBlock theme classes txt + +prettyBlock theme (Pandoc.BulletList bss) = PP.vcat + [ PP.indent + (PP.NotTrimmable $ themed (themeBulletList theme) prefix) + (PP.Trimmable " ") + (prettyBlocks theme' bs) + | bs <- bss + ] <> PP.hardline + where + prefix = " " <> PP.string [marker] <> " " + marker = case T.unpack <$> themeBulletListMarkers theme of + Just (x : _) -> x + _ -> '-' + + -- Cycle the markers. + theme' = theme + { themeBulletListMarkers = + (\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme + } + +prettyBlock theme@Theme {..} (Pandoc.OrderedList _ bss) = PP.vcat + [ PP.indent + (PP.NotTrimmable $ themed themeOrderedList $ PP.string prefix) + (PP.Trimmable " ") + (prettyBlocks theme bs) + | (prefix, bs) <- zip padded bss + ] <> PP.hardline + where + padded = [n ++ replicate (4 - length n) ' ' | n <- numbers] + numbers = + [ show i ++ "." + | i <- [1 .. length bss] + ] + +prettyBlock _theme (Pandoc.RawBlock _ t) = PP.string t <> PP.hardline + +prettyBlock _theme Pandoc.HorizontalRule = "---" + +prettyBlock theme@Theme {..} (Pandoc.BlockQuote bs) = + let quote = PP.NotTrimmable (themed themeBlockQuote "> ") in + PP.indent quote quote (prettyBlocks theme bs) + +prettyBlock theme@Theme {..} (Pandoc.DefinitionList terms) = + PP.vcat $ map prettyDefinition terms + where + prettyDefinition (term, definitions) = + themed themeDefinitionTerm (prettyInlines theme term) <$$> + PP.hardline <> PP.vcat + [ PP.indent + (PP.NotTrimmable (themed themeDefinitionList ": ")) + (PP.Trimmable " ") $ + prettyBlocks theme (Pandoc.plainToPara definition) + | definition <- definitions + ] + +prettyBlock theme (Pandoc.Table caption aligns _ headers rows) = + PP.wrapAt Nothing $ + prettyTable theme Table + { tCaption = prettyInlines theme caption + , tAligns = map align aligns + , tHeaders = map (prettyBlocks theme) headers + , tRows = map (map (prettyBlocks theme)) rows + } + where + align Pandoc.AlignLeft = PP.AlignLeft + align Pandoc.AlignCenter = PP.AlignCenter + align Pandoc.AlignDefault = PP.AlignLeft + align Pandoc.AlignRight = PP.AlignRight + +prettyBlock theme (Pandoc.Div _attrs blocks) = prettyBlocks theme blocks + +prettyBlock _theme Pandoc.Null = mempty + +#if MIN_VERSION_pandoc(1,18,0) +-- 'LineBlock' elements are new in pandoc-1.18 +prettyBlock theme@Theme {..} (Pandoc.LineBlock inliness) = + let ind = PP.NotTrimmable (themed themeLineBlock "| ") in + PP.wrapAt Nothing $ + PP.indent ind ind $ + PP.vcat $ + map (prettyInlines theme) inliness +#endif + + +-------------------------------------------------------------------------------- +prettyBlocks :: Theme -> [Pandoc.Block] -> PP.Doc +prettyBlocks theme = PP.vcat . map (prettyBlock theme) + + +-------------------------------------------------------------------------------- +prettyInline :: Theme -> Pandoc.Inline -> PP.Doc + +prettyInline _theme Pandoc.Space = PP.space + +prettyInline _theme (Pandoc.Str str) = PP.string str + +prettyInline theme@Theme {..} (Pandoc.Emph inlines) = + themed themeEmph $ + prettyInlines theme inlines + +prettyInline theme@Theme {..} (Pandoc.Strong inlines) = + themed themeStrong $ + prettyInlines theme inlines + +prettyInline Theme {..} (Pandoc.Code _ txt) = + themed themeCode $ + " " <> PP.string txt <> " " + +prettyInline theme@Theme {..} link@(Pandoc.Link _attrs text (target, _title)) + | isReferenceLink link = + "[" <> themed themeLinkText (prettyInlines theme text) <> "]" + | otherwise = + "<" <> themed themeLinkTarget (PP.string target) <> ">" + +prettyInline _theme Pandoc.SoftBreak = PP.softline + +prettyInline _theme Pandoc.LineBreak = PP.hardline + +prettyInline theme@Theme {..} (Pandoc.Strikeout t) = + "~~" <> themed themeStrikeout (prettyInlines theme t) <> "~~" + +prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.SingleQuote t) = + "'" <> themed themeQuoted (prettyInlines theme t) <> "'" +prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.DoubleQuote t) = + "'" <> themed themeQuoted (prettyInlines theme t) <> "'" + +prettyInline Theme {..} (Pandoc.Math _ t) = + themed themeMath (PP.string t) + +prettyInline theme@Theme {..} (Pandoc.Image _attrs text (target, _title)) = + "![" <> themed themeImageText (prettyInlines theme text) <> "](" <> + themed themeImageTarget (PP.string target) <> ")" + +-- These elements aren't really supported. +prettyInline theme (Pandoc.Cite _ t) = prettyInlines theme t +prettyInline theme (Pandoc.Span _ t) = prettyInlines theme t +prettyInline _theme (Pandoc.RawInline _ t) = PP.string t +prettyInline theme (Pandoc.Note t) = prettyBlocks theme t +prettyInline theme (Pandoc.Superscript t) = prettyInlines theme t +prettyInline theme (Pandoc.Subscript t) = prettyInlines theme t +prettyInline theme (Pandoc.SmallCaps t) = prettyInlines theme t +-- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported + + +-------------------------------------------------------------------------------- +prettyInlines :: Theme -> [Pandoc.Inline] -> PP.Doc +prettyInlines theme = mconcat . map (prettyInline theme) + + +-------------------------------------------------------------------------------- +prettyReferences :: Theme -> Slide -> [PP.Doc] +prettyReferences theme@Theme {..} = + map prettyReference . getReferences . unSlide + where + getReferences :: [Pandoc.Block] -> [Pandoc.Inline] + getReferences = filter isReferenceLink . grecQ + + prettyReference :: Pandoc.Inline -> PP.Doc + prettyReference (Pandoc.Link _attrs text (target, title)) = + "[" <> + themed themeLinkText (prettyInlines theme $ Pandoc.newlineToSpace text) <> + "](" <> + themed themeLinkTarget (PP.string target) <> + (if null title + then mempty + else PP.space <> "\"" <> PP.string title <> "\"") + <> ")" + prettyReference _ = mempty + + +-------------------------------------------------------------------------------- +isReferenceLink :: Pandoc.Inline -> Bool +isReferenceLink (Pandoc.Link _attrs text (target, _)) = + [Pandoc.Str target] /= text +isReferenceLink _ = False diff --git a/src/Patat/Presentation/Display/CodeBlock.hs b/src/Patat/Presentation/Display/CodeBlock.hs new file mode 100644 index 0000000..4888166 --- /dev/null +++ b/src/Patat/Presentation/Display/CodeBlock.hs @@ -0,0 +1,79 @@ +-------------------------------------------------------------------------------- +-- | Displaying code blocks, optionally with syntax highlighting. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Display.CodeBlock + ( prettyCodeBlock + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (toLower) +import Data.List (find) +import Data.Monoid (mconcat, (<>)) +import qualified Data.Set as S +import Patat.Presentation.Display.Table (themed) +import qualified Patat.PrettyPrint as PP +import Patat.Theme +import qualified Text.Highlighting.Kate as Kate +import Prelude + + +-------------------------------------------------------------------------------- +lower :: String -> String +lower = map toLower + + +-------------------------------------------------------------------------------- +supportedLanguages :: S.Set String +supportedLanguages = S.fromList (map lower Kate.languages) + + +-------------------------------------------------------------------------------- +highlight :: [String] -> String -> [Kate.SourceLine] +highlight classes rawCodeBlock = + case find (\c -> lower c `S.member` supportedLanguages) classes of + Nothing -> zeroHighlight rawCodeBlock + Just lang -> Kate.highlightAs lang rawCodeBlock + + +-------------------------------------------------------------------------------- +-- | This does fake highlighting, everything becomes a normal token. That makes +-- things a bit easier, since we only need to deal with one cases in the +-- renderer. +zeroHighlight :: String -> [Kate.SourceLine] +zeroHighlight str = [[(Kate.NormalTok, line)] | line <- lines str] + + +-------------------------------------------------------------------------------- +prettyCodeBlock :: Theme -> [String] -> String -> PP.Doc +prettyCodeBlock theme@Theme {..} classes rawCodeBlock = + PP.vcat (map blockified sourceLines) <> + PP.hardline + where + sourceLines :: [Kate.SourceLine] + sourceLines = + [[]] ++ highlight classes rawCodeBlock ++ [[]] + + prettySourceLine :: Kate.SourceLine -> PP.Doc + prettySourceLine = mconcat . map prettyToken + + prettyToken :: Kate.Token -> PP.Doc + prettyToken (tokenType, str) = + themed (syntaxHighlight theme tokenType) (PP.string str) + + sourceLineLength :: Kate.SourceLine -> Int + sourceLineLength line = sum [length str | (_, str) <- line] + + blockWidth :: Int + blockWidth = foldr max 0 (map sourceLineLength sourceLines) + + blockified :: Kate.SourceLine -> PP.Doc + blockified line = + let len = sourceLineLength line + indent = PP.NotTrimmable " " in + PP.indent indent indent $ + themed themeCodeBlock $ + " " <> + prettySourceLine line <> + PP.string (replicate (blockWidth - len) ' ') <> " " diff --git a/src/Patat/Presentation/Display/Table.hs b/src/Patat/Presentation/Display/Table.hs new file mode 100644 index 0000000..fee68c9 --- /dev/null +++ b/src/Patat/Presentation/Display/Table.hs @@ -0,0 +1,107 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Display.Table + ( Table (..) + , prettyTable + + , themed + ) where + + +-------------------------------------------------------------------------------- +import Data.List (intersperse, transpose) +import Data.Monoid (mconcat, mempty, (<>)) +import Patat.PrettyPrint ((<$$>)) +import qualified Patat.PrettyPrint as PP +import Patat.Theme (Theme (..)) +import qualified Patat.Theme as Theme +import Prelude + + +-------------------------------------------------------------------------------- +data Table = Table + { tCaption :: PP.Doc + , tAligns :: [PP.Alignment] + , tHeaders :: [PP.Doc] + , tRows :: [[PP.Doc]] + } + + +-------------------------------------------------------------------------------- +prettyTable + :: Theme -> Table -> PP.Doc +prettyTable theme@Theme {..} Table {..} = + PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $ + lineIf (not isHeaderLess) (hcat2 headerHeight + [ themed themeTableHeader (PP.align w a (vpad headerHeight header)) + | (w, a, header) <- zip3 columnWidths tAligns tHeaders + ]) <> + dashedHeaderSeparator theme columnWidths <$$> + joinRows + [ hcat2 rowHeight + [ PP.align w a (vpad rowHeight cell) + | (w, a, cell) <- zip3 columnWidths tAligns row + ] + | (rowHeight, row) <- zip rowHeights tRows + ] <$$> + lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <> + lineIf + (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption) + where + lineIf cond line = if cond then line <> PP.hardline else mempty + + joinRows + | all (all isSimpleCell) tRows = PP.vcat + | otherwise = PP.vcat . intersperse "" + + isHeaderLess = all PP.null tHeaders + + headerDimensions = map PP.dimensions tHeaders :: [(Int, Int)] + rowDimensions = map (map PP.dimensions) tRows :: [[(Int, Int)]] + + columnWidths :: [Int] + columnWidths = + [ safeMax (map snd col) + | col <- transpose (headerDimensions : rowDimensions) + ] + + rowHeights = map (safeMax . map fst) rowDimensions :: [Int] + headerHeight = safeMax (map fst headerDimensions) :: Int + + vpad :: Int -> PP.Doc -> PP.Doc + vpad height doc = + let (actual, _) = PP.dimensions doc in + doc <> mconcat (replicate (height - actual) PP.hardline) + + safeMax = foldr max 0 + + hcat2 :: Int -> [PP.Doc] -> PP.Doc + hcat2 rowHeight = PP.paste . intersperse (spaces2 rowHeight) + + spaces2 :: Int -> PP.Doc + spaces2 rowHeight = + mconcat $ intersperse PP.hardline $ + replicate rowHeight (PP.string " ") + + +-------------------------------------------------------------------------------- +isSimpleCell :: PP.Doc -> Bool +isSimpleCell = (<= 1) . fst . PP.dimensions + + +-------------------------------------------------------------------------------- +dashedHeaderSeparator :: Theme -> [Int] -> PP.Doc +dashedHeaderSeparator Theme {..} columnWidths = + mconcat $ intersperse (PP.string " ") + [ themed themeTableSeparator (PP.string (replicate w '-')) + | w <- columnWidths + ] + + +-------------------------------------------------------------------------------- +-- | This does not really belong in the module. +themed :: Maybe Theme.Style -> PP.Doc -> PP.Doc +themed Nothing = id +themed (Just (Theme.Style [])) = id +themed (Just (Theme.Style codes)) = PP.ansi codes diff --git a/src/Patat/Presentation/Interactive.hs b/src/Patat/Presentation/Interactive.hs new file mode 100644 index 0000000..226a715 --- /dev/null +++ b/src/Patat/Presentation/Interactive.hs @@ -0,0 +1,100 @@ +-------------------------------------------------------------------------------- +-- | Module that allows the user to interact with the presentation +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Interactive + ( PresentationCommand (..) + , readPresentationCommand + + , UpdatedPresentation (..) + , updatePresentation + ) where + + +-------------------------------------------------------------------------------- +import Patat.Presentation.Internal +import Patat.Presentation.Read + + +-------------------------------------------------------------------------------- +data PresentationCommand + = Exit + | Forward + | Backward + | SkipForward + | SkipBackward + | First + | Last + | Reload + + +-------------------------------------------------------------------------------- +readPresentationCommand :: IO PresentationCommand +readPresentationCommand = do + k <- readKey + case k of + "q" -> return Exit + "\n" -> return Forward + "\DEL" -> return Backward + "h" -> return Backward + "j" -> return SkipForward + "k" -> return SkipBackward + "l" -> return Forward + "\ESC[C" -> return Forward + "\ESC[D" -> return Backward + "\ESC[B" -> return SkipForward + "\ESC[A" -> return SkipBackward + "0" -> return First + "G" -> return Last + "r" -> return Reload + _ -> readPresentationCommand + where + readKey :: IO String + readKey = do + c0 <- getChar + case c0 of + '\ESC' -> do + c1 <- getChar + case c1 of + '[' -> do + c2 <- getChar + return [c0, c1, c2] + _ -> return [c0, c1] + _ -> return [c0] + + +-------------------------------------------------------------------------------- +data UpdatedPresentation + = UpdatedPresentation !Presentation + | ExitedPresentation + | ErroredPresentation String + deriving (Show) + + +-------------------------------------------------------------------------------- +updatePresentation + :: PresentationCommand -> Presentation -> IO UpdatedPresentation + +updatePresentation cmd presentation = case cmd of + Exit -> return ExitedPresentation + Forward -> return $ goToSlide (\x -> x + 1) + Backward -> return $ goToSlide (\x -> x - 1) + SkipForward -> return $ goToSlide (\x -> x + 10) + SkipBackward -> return $ goToSlide (\x -> x - 10) + First -> return $ goToSlide (\_ -> 0) + Last -> return $ goToSlide (\_ -> numSlides presentation - 1) + Reload -> reloadPresentation + where + numSlides pres = length (pSlides pres) + clip idx pres = min (max 0 idx) (numSlides pres - 1) + + goToSlide f = UpdatedPresentation $ + presentation {pActiveSlide = clip (f $ pActiveSlide presentation) presentation} + + reloadPresentation = do + errOrPres <- readPresentation (pFilePath presentation) + return $ case errOrPres of + Left err -> ErroredPresentation err + Right pres -> UpdatedPresentation $ + pres {pActiveSlide = clip (pActiveSlide presentation) pres} diff --git a/src/Patat/Presentation/Internal.hs b/src/Patat/Presentation/Internal.hs new file mode 100644 index 0000000..f11c46b --- /dev/null +++ b/src/Patat/Presentation/Internal.hs @@ -0,0 +1,71 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +module Patat.Presentation.Internal + ( Presentation (..) + , PresentationSettings (..) + , defaultPresentationSettings + , Slide (..) + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (mplus) +import qualified Data.Aeson.Extended as A +import qualified Data.Aeson.TH.Extended as A +import Data.Monoid (Monoid (..)) +import qualified Patat.Theme as Theme +import qualified Text.Pandoc as Pandoc +import Prelude + + +-------------------------------------------------------------------------------- +data Presentation = Presentation + { pFilePath :: !FilePath + , pTitle :: ![Pandoc.Inline] + , pAuthor :: ![Pandoc.Inline] + , pSettings :: !PresentationSettings + , pSlides :: [Slide] + , pActiveSlide :: !Int + } deriving (Show) + + +-------------------------------------------------------------------------------- +-- | These are patat-specific settings. That is where they differ from more +-- general metadata (author, title...) +data PresentationSettings = PresentationSettings + { psRows :: !(Maybe (A.FlexibleNum Int)) + , psColumns :: !(Maybe (A.FlexibleNum Int)) + , psWrap :: !(Maybe Bool) + , psTheme :: !(Maybe Theme.Theme) + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Monoid PresentationSettings where + mempty = PresentationSettings Nothing Nothing Nothing Nothing + mappend l r = PresentationSettings + { psRows = psRows l `mplus` psRows r + , psColumns = psColumns l `mplus` psColumns r + , psWrap = psWrap l `mplus` psWrap r + , psTheme = psTheme l `mappend` psTheme r + } + + +-------------------------------------------------------------------------------- +defaultPresentationSettings :: PresentationSettings +defaultPresentationSettings = PresentationSettings + { psRows = Nothing + , psColumns = Nothing + , psWrap = Nothing + , psTheme = Just Theme.defaultTheme + } + + +-------------------------------------------------------------------------------- +newtype Slide = Slide {unSlide :: [Pandoc.Block]} + deriving (Monoid, Show) + + +-------------------------------------------------------------------------------- +$(A.deriveJSON A.dropPrefixOptions ''PresentationSettings) diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs new file mode 100644 index 0000000..c962632 --- /dev/null +++ b/src/Patat/Presentation/Read.hs @@ -0,0 +1,121 @@ +-- | Read a presentation from disk. +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.Presentation.Read + ( readPresentation + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad.Except (ExceptT (..), runExceptT, + throwError) +import Control.Monad.Trans (liftIO) +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import Data.Monoid (mempty, (<>)) +import qualified Data.Set as Set +import qualified Data.Yaml as Yaml +import Patat.Presentation.Internal +import System.Directory (doesFileExist, getHomeDirectory) +import System.FilePath (takeExtension, ()) +import qualified Text.Pandoc.Error as Pandoc +import qualified Text.Pandoc.Extended as Pandoc +import Prelude + + +-------------------------------------------------------------------------------- +readPresentation :: FilePath -> IO (Either String Presentation) +readPresentation filePath = runExceptT $ do + src <- liftIO $ readFile filePath + reader <- case readExtension ext of + Nothing -> throwError $ "Unknown file extension: " ++ show ext + Just x -> return x + doc@(Pandoc.Pandoc meta _) <- case reader src of + Left e -> throwError $ "Could not parse document: " ++ show e + Right x -> return x + + homeSettings <- ExceptT readHomeSettings + metaSettings <- ExceptT $ return $ readMetaSettings meta + let settings = metaSettings <> homeSettings <> defaultPresentationSettings + + ExceptT $ return $ pandocToPresentation filePath settings doc + where + ext = takeExtension filePath + + +-------------------------------------------------------------------------------- +readExtension + :: String -> Maybe (String -> Either Pandoc.PandocError Pandoc.Pandoc) +readExtension fileExt = case fileExt of + ".md" -> Just $ Pandoc.readMarkdown Pandoc.def + ".lhs" -> Just $ Pandoc.readMarkdown lhsOpts + "" -> Just $ Pandoc.readMarkdown Pandoc.def + ".org" -> Just $ Pandoc.readOrg Pandoc.def + _ -> Nothing + + where + lhsOpts = Pandoc.def + { Pandoc.readerExtensions = Set.insert Pandoc.Ext_literate_haskell + (Pandoc.readerExtensions Pandoc.def) + } + + +-------------------------------------------------------------------------------- +pandocToPresentation + :: FilePath -> PresentationSettings -> Pandoc.Pandoc + -> Either String Presentation +pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do + let !pTitle = Pandoc.docTitle meta + !pSlides = pandocToSlides pandoc + !pActiveSlide = 0 + !pAuthor = concat (Pandoc.docAuthors meta) + return Presentation {..} + + +-------------------------------------------------------------------------------- +-- | Read settings from the metadata block in the Pandoc document. +readMetaSettings :: Pandoc.Meta -> Either String PresentationSettings +readMetaSettings meta = case Pandoc.lookupMeta "patat" meta of + Nothing -> return mempty + Just val -> resultToEither $! A.fromJSON $! Pandoc.metaToJson val + where + resultToEither :: A.Result a -> Either String a + resultToEither (A.Success x) = Right x + resultToEither (A.Error e) = Left $! + "Error parsing patat settings from metadata: " ++ e + + +-------------------------------------------------------------------------------- +-- | Read settings from "$HOME/.patat.yaml". +readHomeSettings :: IO (Either String PresentationSettings) +readHomeSettings = do + home <- getHomeDirectory + let path = home ".patat.yaml" + exists <- doesFileExist path + if not exists + then return (Right mempty) + else do + contents <- B.readFile path + return $! Yaml.decodeEither contents + + +-------------------------------------------------------------------------------- +-- | Split a pandoc document into slides. If the document contains horizonal +-- rules, we use those as slide delimiters. If there are no horizontal rules, +-- we split using h1 headers. +pandocToSlides :: Pandoc.Pandoc -> [Slide] +pandocToSlides (Pandoc.Pandoc _meta blocks0) + | any (== Pandoc.HorizontalRule) blocks0 = splitAtRules blocks0 + | otherwise = splitAtH1s blocks0 + where + splitAtRules blocks = case break (== Pandoc.HorizontalRule) blocks of + (xs, []) -> [Slide xs] + (xs, (_rule : ys)) -> Slide xs : splitAtRules ys + + splitAtH1s [] = [] + splitAtH1s (b : bs) = case break isH1 bs of + (xs, []) -> [Slide (b : xs)] + (xs, (y : ys)) -> Slide (b : xs) : splitAtH1s (y : ys) + + isH1 (Pandoc.Header i _ _) = i == 1 + isH1 _ = False diff --git a/src/Patat/PrettyPrint.hs b/src/Patat/PrettyPrint.hs new file mode 100644 index 0000000..7b24b37 --- /dev/null +++ b/src/Patat/PrettyPrint.hs @@ -0,0 +1,404 @@ +-------------------------------------------------------------------------------- +-- | This is a small pretty-printing library. +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +module Patat.PrettyPrint + ( Doc + , toString + , dimensions + , null + + , hPutDoc + , putDoc + + , string + , text + , space + , softline + , hardline + + , wrapAt + + , Trimmable (..) + , indent + + , ansi + + , (<+>) + , (<$$>) + , vcat + + -- * Exotic combinators + , Alignment (..) + , align + , paste + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad.Reader (asks, local) +import Control.Monad.RWS (RWS, runRWS) +import Control.Monad.State (get, gets, modify) +import Control.Monad.Writer (tell) +import Data.Foldable (Foldable) +import qualified Data.List as L +import Data.Monoid (Monoid, mconcat, mempty, (<>)) +import Data.String (IsString (..)) +import qualified Data.Text as T +import Data.Traversable (Traversable, traverse) +import qualified System.Console.ANSI as Ansi +import qualified System.IO as IO +import Prelude hiding (null) + + +-------------------------------------------------------------------------------- +-- | A simple chunk of text. All ANSI codes are "reset" after printing. +data Chunk + = StringChunk [Ansi.SGR] String + | NewlineChunk + deriving (Eq) + + +-------------------------------------------------------------------------------- +type Chunks = [Chunk] + + +-------------------------------------------------------------------------------- +hPutChunk :: IO.Handle -> Chunk -> IO () +hPutChunk h NewlineChunk = IO.hPutStrLn h "" +hPutChunk h (StringChunk codes str) = do + Ansi.hSetSGR h (reverse codes) + IO.hPutStr h str + Ansi.hSetSGR h [Ansi.Reset] + + +-------------------------------------------------------------------------------- +chunkToString :: Chunk -> String +chunkToString NewlineChunk = "\n" +chunkToString (StringChunk _ str) = str + + +-------------------------------------------------------------------------------- +-- | If two neighboring chunks have the same set of ANSI codes, we can group +-- them together. +optimizeChunks :: Chunks -> Chunks +optimizeChunks (StringChunk c1 s1 : StringChunk c2 s2 : chunks) + | c1 == c2 = optimizeChunks (StringChunk c1 (s1 <> s2) : chunks) + | otherwise = + StringChunk c1 s1 : optimizeChunks (StringChunk c2 s2 : chunks) +optimizeChunks (x : chunks) = x : optimizeChunks chunks +optimizeChunks [] = [] + + +-------------------------------------------------------------------------------- +chunkLines :: Chunks -> [Chunks] +chunkLines chunks = case break (== NewlineChunk) chunks of + (xs, _newline : ys) -> xs : chunkLines ys + (xs, []) -> [xs] + + +-------------------------------------------------------------------------------- +data DocE + = String String + | Softspace + | Hardspace + | Softline + | Hardline + | WrapAt + { wrapAtCol :: Maybe Int + , wrapDoc :: Doc + } + | Ansi + { ansiCode :: [Ansi.SGR] -> [Ansi.SGR] -- ^ Modifies current codes. + , ansiDoc :: Doc + } + | Indent + { indentFirstLine :: LineBuffer + , indentOtherLines :: LineBuffer + , indentDoc :: Doc + } + + +-------------------------------------------------------------------------------- +chunkToDocE :: Chunk -> DocE +chunkToDocE NewlineChunk = Hardline +chunkToDocE (StringChunk codes str) = Ansi (\_ -> codes) (Doc [String str]) + + +-------------------------------------------------------------------------------- +newtype Doc = Doc {unDoc :: [DocE]} + deriving (Monoid) + + +-------------------------------------------------------------------------------- +instance IsString Doc where + fromString = string + + +-------------------------------------------------------------------------------- +instance Show Doc where + show = toString + + +-------------------------------------------------------------------------------- +data DocEnv = DocEnv + { deCodes :: [Ansi.SGR] -- ^ Most recent ones first in the list + , deIndent :: LineBuffer -- ^ Don't need to store first-line indent + , deWrap :: Maybe Int -- ^ Wrap at columns + } + + +-------------------------------------------------------------------------------- +type DocM = RWS DocEnv Chunks LineBuffer + + +-------------------------------------------------------------------------------- +data Trimmable a + = NotTrimmable !a + | Trimmable !a + deriving (Foldable, Functor, Traversable) + + +-------------------------------------------------------------------------------- +-- | Note that this is reversed so we have fast append +type LineBuffer = [Trimmable Chunk] + + +-------------------------------------------------------------------------------- +bufferToChunks :: LineBuffer -> Chunks +bufferToChunks = map trimmableToChunk . reverse . dropWhile isTrimmable + where + isTrimmable (NotTrimmable _) = False + isTrimmable (Trimmable _) = True + + trimmableToChunk (NotTrimmable c) = c + trimmableToChunk (Trimmable c) = c + + +-------------------------------------------------------------------------------- +docToChunks :: Doc -> Chunks +docToChunks doc0 = + let env0 = DocEnv [] [] Nothing + ((), b, cs) = runRWS (go $ unDoc doc0) env0 mempty in + optimizeChunks (cs <> bufferToChunks b) + where + go :: [DocE] -> DocM () + + go [] = return () + + go (String str : docs) = do + chunk <- makeChunk str + modify (NotTrimmable chunk :) + go docs + + go (Softspace : docs) = do + hard <- softConversion Softspace docs + go (hard : docs) + + go (Hardspace : docs) = do + chunk <- makeChunk " " + modify (NotTrimmable chunk :) + go docs + + go (Softline : docs) = do + hard <- softConversion Softline docs + go (hard : docs) + + go (Hardline : docs) = do + buffer <- get + tell $ bufferToChunks buffer <> [NewlineChunk] + indentation <- asks deIndent + modify $ \_ -> if L.null docs then [] else indentation + go docs + + go (WrapAt {..} : docs) = do + local (\env -> env {deWrap = wrapAtCol}) $ go (unDoc wrapDoc) + go docs + + go (Ansi {..} : docs) = do + local (\env -> env {deCodes = ansiCode (deCodes env)}) $ + go (unDoc ansiDoc) + go docs + + go (Indent {..} : docs) = do + local (\env -> env {deIndent = indentOtherLines ++ deIndent env}) $ do + modify (indentFirstLine ++) + go (unDoc indentDoc) + go docs + + makeChunk :: String -> DocM Chunk + makeChunk str = do + codes <- asks deCodes + return $ StringChunk codes str + + -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline' + softConversion :: DocE -> [DocE] -> DocM DocE + softConversion soft docs = do + mbWrapCol <- asks deWrap + case mbWrapCol of + Nothing -> return hard + Just maxCol -> do + -- Slow. + currentLine <- gets (concatMap chunkToString . bufferToChunks) + let currentCol = length currentLine + case nextWordLength docs of + Nothing -> return hard + Just l + | currentCol + 1 + l <= maxCol -> return Hardspace + | otherwise -> return Hardline + where + hard = case soft of + Softspace -> Hardspace + Softline -> Hardline + _ -> soft + + nextWordLength :: [DocE] -> Maybe Int + nextWordLength [] = Nothing + nextWordLength (String x : xs) + | L.null x = nextWordLength xs + | otherwise = Just (length x) + nextWordLength (Softspace : xs) = nextWordLength xs + nextWordLength (Hardspace : xs) = nextWordLength xs + nextWordLength (Softline : xs) = nextWordLength xs + nextWordLength (Hardline : _) = Nothing + nextWordLength (WrapAt {..} : xs) = nextWordLength (unDoc wrapDoc ++ xs) + nextWordLength (Ansi {..} : xs) = nextWordLength (unDoc ansiDoc ++ xs) + nextWordLength (Indent {..} : xs) = nextWordLength (unDoc indentDoc ++ xs) + + +-------------------------------------------------------------------------------- +toString :: Doc -> String +toString = concat . map chunkToString . docToChunks + + +-------------------------------------------------------------------------------- +-- | Returns the rows and columns necessary to render this document +dimensions :: Doc -> (Int, Int) +dimensions doc = + let ls = lines (toString doc) in + (length ls, foldr max 0 (map length ls)) + + +-------------------------------------------------------------------------------- +null :: Doc -> Bool +null doc = case unDoc doc of [] -> True; _ -> False + + +-------------------------------------------------------------------------------- +hPutDoc :: IO.Handle -> Doc -> IO () +hPutDoc h = mapM_ (hPutChunk h) . docToChunks + + +-------------------------------------------------------------------------------- +putDoc :: Doc -> IO () +putDoc = hPutDoc IO.stdout + + +-------------------------------------------------------------------------------- +mkDoc :: DocE -> Doc +mkDoc e = Doc [e] + + +-------------------------------------------------------------------------------- +string :: String -> Doc +string = mkDoc . String -- TODO (jaspervdj): Newline conversion + + +-------------------------------------------------------------------------------- +text :: T.Text -> Doc +text = string . T.unpack + + +-------------------------------------------------------------------------------- +space :: Doc +space = mkDoc Softspace + + +-------------------------------------------------------------------------------- +softline :: Doc +softline = mkDoc Softline + + +-------------------------------------------------------------------------------- +hardline :: Doc +hardline = mkDoc Hardline + + +-------------------------------------------------------------------------------- +wrapAt :: Maybe Int -> Doc -> Doc +wrapAt wrapAtCol wrapDoc = mkDoc WrapAt {..} + + +-------------------------------------------------------------------------------- +indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc +indent firstLineDoc otherLinesDoc doc = mkDoc $ Indent + { indentFirstLine = traverse docToChunks firstLineDoc + , indentOtherLines = traverse docToChunks otherLinesDoc + , indentDoc = doc + } + + +-------------------------------------------------------------------------------- +ansi :: [Ansi.SGR] -> Doc -> Doc +ansi codes = mkDoc . Ansi (codes ++) + + +-------------------------------------------------------------------------------- +(<+>) :: Doc -> Doc -> Doc +x <+> y = x <> space <> y +infixr 6 <+> + + +-------------------------------------------------------------------------------- +(<$$>) :: Doc -> Doc -> Doc +x <$$> y = x <> hardline <> y +infixr 5 <$$> + + +-------------------------------------------------------------------------------- +vcat :: [Doc] -> Doc +vcat = mconcat . L.intersperse hardline + + +-------------------------------------------------------------------------------- +data Alignment = AlignLeft | AlignCenter | AlignRight deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- +align :: Int -> Alignment -> Doc -> Doc +align width alignment doc0 = + let chunks0 = docToChunks doc0 + lines_ = chunkLines chunks0 in + vcat + [ Doc (map chunkToDocE (alignLine line)) + | line <- lines_ + ] + where + lineWidth :: [Chunk] -> Int + lineWidth = sum . map (length . chunkToString) + + alignLine :: [Chunk] -> [Chunk] + alignLine line = + let actual = lineWidth line + spaces n = [StringChunk [] (replicate n ' ')] in + case alignment of + AlignLeft -> line <> spaces (width - actual) + AlignRight -> spaces (width - actual) <> line + AlignCenter -> + let r = (width - actual) `div` 2 + l = (width - actual) - r in + spaces l <> line <> spaces r + + +-------------------------------------------------------------------------------- +-- | Like the unix program 'paste'. +paste :: [Doc] -> Doc +paste docs0 = + let chunkss = map docToChunks docs0 :: [Chunks] + cols = map chunkLines chunkss :: [[Chunks]] + rows0 = L.transpose cols :: [[Chunks]] + rows1 = map (map (Doc . map chunkToDocE)) rows0 :: [[Doc]] in + vcat $ map mconcat rows1 diff --git a/src/Patat/Theme.hs b/src/Patat/Theme.hs new file mode 100644 index 0000000..706f825 --- /dev/null +++ b/src/Patat/Theme.hs @@ -0,0 +1,286 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Patat.Theme + ( Theme (..) + , defaultTheme + + , Style (..) + + , SyntaxHighlighting (..) + , defaultSyntaxHighlighting + , syntaxHighlight + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (forM_, mplus) +import qualified Data.Aeson as A +import qualified Data.Aeson.TH.Extended as A +import Data.Char (toLower, toUpper) +import Data.List (intercalate, isSuffixOf) +import qualified Data.Map as M +import Data.Maybe (mapMaybe, maybeToList) +import Data.Monoid (Monoid (..), (<>)) +import qualified Data.Text as T +import qualified System.Console.ANSI as Ansi +import qualified Text.Highlighting.Kate as Kate +import Text.Read (readMaybe) +import Prelude + + +-------------------------------------------------------------------------------- +data Theme = Theme + { themeBorders :: !(Maybe Style) + , themeHeader :: !(Maybe Style) + , themeCodeBlock :: !(Maybe Style) + , themeBulletList :: !(Maybe Style) + , themeBulletListMarkers :: !(Maybe T.Text) + , themeOrderedList :: !(Maybe Style) + , themeBlockQuote :: !(Maybe Style) + , themeDefinitionTerm :: !(Maybe Style) + , themeDefinitionList :: !(Maybe Style) + , themeTableHeader :: !(Maybe Style) + , themeTableSeparator :: !(Maybe Style) + , themeLineBlock :: !(Maybe Style) + , themeEmph :: !(Maybe Style) + , themeStrong :: !(Maybe Style) + , themeCode :: !(Maybe Style) + , themeLinkText :: !(Maybe Style) + , themeLinkTarget :: !(Maybe Style) + , themeStrikeout :: !(Maybe Style) + , themeQuoted :: !(Maybe Style) + , themeMath :: !(Maybe Style) + , themeImageText :: !(Maybe Style) + , themeImageTarget :: !(Maybe Style) + , themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting) + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Monoid Theme where + mempty = Theme + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + + mappend l r = Theme + { themeBorders = mplusOn themeBorders + , themeHeader = mplusOn themeHeader + , themeCodeBlock = mplusOn themeCodeBlock + , themeBulletList = mplusOn themeBulletList + , themeBulletListMarkers = mplusOn themeBulletListMarkers + , themeOrderedList = mplusOn themeOrderedList + , themeBlockQuote = mplusOn themeBlockQuote + , themeDefinitionTerm = mplusOn themeDefinitionTerm + , themeDefinitionList = mplusOn themeDefinitionList + , themeTableHeader = mplusOn themeTableHeader + , themeTableSeparator = mplusOn themeTableSeparator + , themeLineBlock = mplusOn themeLineBlock + , themeEmph = mplusOn themeEmph + , themeStrong = mplusOn themeStrong + , themeCode = mplusOn themeCode + , themeLinkText = mplusOn themeLinkText + , themeLinkTarget = mplusOn themeLinkTarget + , themeStrikeout = mplusOn themeStrikeout + , themeQuoted = mplusOn themeQuoted + , themeMath = mplusOn themeMath + , themeImageText = mplusOn themeImageText + , themeImageTarget = mplusOn themeImageTarget + , themeSyntaxHighlighting = mappendOn themeSyntaxHighlighting + } + where + mplusOn f = f l `mplus` f r + mappendOn f = f l `mappend` f r + + +-------------------------------------------------------------------------------- +defaultTheme :: Theme +defaultTheme = Theme + { themeBorders = dull Ansi.Yellow + , themeHeader = dull Ansi.Blue + , themeCodeBlock = dull Ansi.White <> ondull Ansi.Black + , themeBulletList = dull Ansi.Magenta + , themeBulletListMarkers = Just "-*" + , themeOrderedList = dull Ansi.Magenta + , themeBlockQuote = dull Ansi.Green + , themeDefinitionTerm = dull Ansi.Blue + , themeDefinitionList = dull Ansi.Magenta + , themeTableHeader = dull Ansi.Blue + , themeTableSeparator = dull Ansi.Magenta + , themeLineBlock = dull Ansi.Magenta + , themeEmph = dull Ansi.Green + , themeStrong = dull Ansi.Red <> bold + , themeCode = dull Ansi.White <> ondull Ansi.Black + , themeLinkText = dull Ansi.Green + , themeLinkTarget = dull Ansi.Cyan <> underline + , themeStrikeout = ondull Ansi.Red + , themeQuoted = dull Ansi.Green + , themeMath = dull Ansi.Green + , themeImageText = dull Ansi.Green + , themeImageTarget = dull Ansi.Cyan <> underline + , themeSyntaxHighlighting = Just defaultSyntaxHighlighting + } + where + dull c = Just $ Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c] + ondull c = Just $ Style [Ansi.SetColor Ansi.Background Ansi.Dull c] + bold = Just $ Style [Ansi.SetConsoleIntensity Ansi.BoldIntensity] + underline = Just $ Style [Ansi.SetUnderlining Ansi.SingleUnderline] + + +-------------------------------------------------------------------------------- +newtype Style = Style {unStyle :: [Ansi.SGR]} + deriving (Monoid, Show) + + +-------------------------------------------------------------------------------- +instance A.ToJSON Style where + toJSON = A.toJSON . mapMaybe nameForSGR . unStyle + + +-------------------------------------------------------------------------------- +instance A.FromJSON Style where + parseJSON val = do + names <- A.parseJSON val + sgrs <- mapM toSgr names + return $! Style sgrs + where + toSgr name = case M.lookup name sgrsByName of + Just sgr -> return sgr + Nothing -> fail $! + "Unknown style: " ++ show name ++ ". Known styles are: " ++ + intercalate ", " (map show $ M.keys sgrsByName) + + +-------------------------------------------------------------------------------- +nameForSGR :: Ansi.SGR -> Maybe String +nameForSGR (Ansi.SetColor layer intensity color) = Just $ + (\str -> case layer of + Ansi.Foreground -> str + Ansi.Background -> "on" ++ capitalize str) $ + (case intensity of + Ansi.Dull -> "dull" + Ansi.Vivid -> "vivid") ++ + (case color of + Ansi.Black -> "Black" + Ansi.Red -> "Red" + Ansi.Green -> "Green" + Ansi.Yellow -> "Yellow" + Ansi.Blue -> "Blue" + Ansi.Magenta -> "Magenta" + Ansi.Cyan -> "Cyan" + Ansi.White -> "White") + +nameForSGR (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline" + +nameForSGR (Ansi.SetConsoleIntensity Ansi.BoldIntensity) = Just "bold" + +nameForSGR _ = Nothing + + +-------------------------------------------------------------------------------- +sgrsByName :: M.Map String Ansi.SGR +sgrsByName = M.fromList + [ (name, sgr) + | sgr <- knownSgrs + , name <- maybeToList (nameForSGR sgr) + ] + where + -- | It doesn't really matter if we generate "too much" SGRs here since + -- 'nameForSGR' will only pick the ones we support. + knownSgrs = + [ Ansi.SetColor l i c + | l <- [minBound .. maxBound] + , i <- [minBound .. maxBound] + , c <- [minBound .. maxBound] + ] ++ + [Ansi.SetUnderlining u | u <- [minBound .. maxBound]] ++ + [Ansi.SetConsoleIntensity c | c <- [minBound .. maxBound]] + + +-------------------------------------------------------------------------------- +newtype SyntaxHighlighting = SyntaxHighlighting + { unSyntaxHighlighting :: M.Map String Style + } deriving (Monoid, Show, A.ToJSON) + + +-------------------------------------------------------------------------------- +instance A.FromJSON SyntaxHighlighting where + parseJSON val = do + styleMap <- A.parseJSON val + forM_ (M.keys styleMap) $ \k -> case nameToTokenType k of + Just _ -> return () + Nothing -> fail $ "Unknown token type: " ++ show k + return (SyntaxHighlighting styleMap) + + +-------------------------------------------------------------------------------- +defaultSyntaxHighlighting :: SyntaxHighlighting +defaultSyntaxHighlighting = mkSyntaxHighlighting + [ (Kate.KeywordTok, dull Ansi.Yellow) + , (Kate.ControlFlowTok, dull Ansi.Yellow) + + , (Kate.DataTypeTok, dull Ansi.Green) + + , (Kate.DecValTok, dull Ansi.Red) + , (Kate.BaseNTok, dull Ansi.Red) + , (Kate.FloatTok, dull Ansi.Red) + , (Kate.ConstantTok, dull Ansi.Red) + , (Kate.CharTok, dull Ansi.Red) + , (Kate.SpecialCharTok, dull Ansi.Red) + , (Kate.StringTok, dull Ansi.Red) + , (Kate.VerbatimStringTok, dull Ansi.Red) + , (Kate.SpecialStringTok, dull Ansi.Red) + + , (Kate.CommentTok, dull Ansi.Blue) + , (Kate.DocumentationTok, dull Ansi.Blue) + , (Kate.AnnotationTok, dull Ansi.Blue) + , (Kate.CommentVarTok, dull Ansi.Blue) + + , (Kate.ImportTok, dull Ansi.Cyan) + , (Kate.OperatorTok, dull Ansi.Cyan) + , (Kate.FunctionTok, dull Ansi.Cyan) + , (Kate.PreprocessorTok, dull Ansi.Cyan) + ] + where + dull c = Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c] + + mkSyntaxHighlighting ls = SyntaxHighlighting $ + M.fromList [(nameForTokenType tt, s) | (tt, s) <- ls] + + +-------------------------------------------------------------------------------- +nameForTokenType :: Kate.TokenType -> String +nameForTokenType = + unCapitalize . dropTok . show + where + unCapitalize (x : xs) = toLower x : xs + unCapitalize xs = xs + + dropTok :: String -> String + dropTok str + | "Tok" `isSuffixOf` str = take (length str - 3) str + | otherwise = str + + +-------------------------------------------------------------------------------- +nameToTokenType :: String -> Maybe Kate.TokenType +nameToTokenType = readMaybe . capitalize . (++ "Tok") + + +-------------------------------------------------------------------------------- +capitalize :: String -> String +capitalize "" = "" +capitalize (x : xs) = toUpper x : xs + + +-------------------------------------------------------------------------------- +syntaxHighlight :: Theme -> Kate.TokenType -> Maybe Style +syntaxHighlight theme tokenType = do + sh <- themeSyntaxHighlighting theme + M.lookup (nameForTokenType tokenType) (unSyntaxHighlighting sh) + + +-------------------------------------------------------------------------------- +$(A.deriveJSON A.dropPrefixOptions ''Theme) diff --git a/src/Text/Pandoc/Extended.hs b/src/Text/Pandoc/Extended.hs new file mode 100644 index 0000000..ab139a9 --- /dev/null +++ b/src/Text/Pandoc/Extended.hs @@ -0,0 +1,50 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +module Text.Pandoc.Extended + ( module Text.Pandoc + + , plainToPara + , newlineToSpace + , metaToJson + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.Aeson as A +import Data.Data.Extended (grecT) +import qualified Data.Map as M +import Data.Monoid (mempty) +import Text.Pandoc +import Prelude + + +-------------------------------------------------------------------------------- +plainToPara :: [Block] -> [Block] +plainToPara = map $ \case + Plain inlines -> Para inlines + block -> block + + +-------------------------------------------------------------------------------- +newlineToSpace :: [Inline] -> [Inline] +newlineToSpace = grecT $ \case + SoftBreak -> Space + LineBreak -> Space + inline -> inline + + +-------------------------------------------------------------------------------- +-- | Convert Pandoc's internal metadata value format to JSON. This makes +-- parsing some things a bit easier. +metaToJson :: MetaValue -> A.Value +metaToJson (MetaMap m) = A.toJSON $! M.map metaToJson m +metaToJson (MetaList l) = A.toJSON $! map metaToJson l +metaToJson (MetaBool b) = A.toJSON b +metaToJson (MetaString s) = A.toJSON s +metaToJson (MetaInlines i) = + let !t = writeMarkdown def (Pandoc mempty [Plain i]) :: String in + A.toJSON t +metaToJson (MetaBlocks b) = + let !t = writeMarkdown def (Pandoc mempty b) :: String in + A.toJSON t diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..e3c2c1e --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +resolver: lts-7.0 +packages: +- '.' +extra-deps: [] +flags: {} +extra-package-dbs: [] diff --git a/test.sh b/test.sh new file mode 100644 index 0000000..9f8e48d --- /dev/null +++ b/test.sh @@ -0,0 +1,30 @@ +#!/bin/bash +set -o nounset -o errexit -o pipefail + +srcs=$(find tests -type f ! -name '*.dump') +stuff_went_wrong=false + +for src in $srcs; do + expected="$src.dump" + echo -n "Testing $src... " + actual=$(mktemp) + patat --dump --force "$src" >"$actual" + + if [[ $@ == "--fix" ]]; then + cp "$actual" "$expected" + echo 'Fixed' + elif [[ ! -f "$expected" ]]; then + echo "missing file: $expected" + stuff_went_wrong=true + elif [[ "$(cat "$expected")" == "$(cat "$actual")" ]]; then + echo 'OK' + else + echo 'files differ' + diff "$actual" "$expected" || true + stuff_went_wrong=true + fi +done + +if [[ "$stuff_went_wrong" = true ]]; then + exit 1 +fi diff --git a/tests/01.md b/tests/01.md new file mode 100644 index 0000000..2fbdde2 --- /dev/null +++ b/tests/01.md @@ -0,0 +1,14 @@ +--- +title: This is my presentation +author: Jasper Van der Jeugt +... + +# This is a test + +Hello world + +--- + +# This is a second slide + +lololol diff --git a/tests/01.md.dump b/tests/01.md.dump new file mode 100644 index 0000000..1ae41da --- /dev/null +++ b/tests/01.md.dump @@ -0,0 +1,8 @@ +# This is a test + +Hello world + +---------- +# This is a second slide + +lololol diff --git a/tests/02.lhs b/tests/02.lhs new file mode 100644 index 0000000..e61c2d0 --- /dev/null +++ b/tests/02.lhs @@ -0,0 +1,6 @@ +This is how to do _Hello World_ in Haskell: + +> main :: IO () +> main = putStrLn "Hello World!" + +Cool, right? diff --git a/tests/02.lhs.dump b/tests/02.lhs.dump new file mode 100644 index 0000000..594c1bd --- /dev/null +++ b/tests/02.lhs.dump @@ -0,0 +1,8 @@ +This is how to do Hello World in Haskell: + +   +  main :: IO ()  +  main = putStrLn "Hello World!"  +   + +Cool, right? diff --git a/tests/03.md b/tests/03.md new file mode 100644 index 0000000..6b3ae16 --- /dev/null +++ b/tests/03.md @@ -0,0 +1,46 @@ +Inline markups: + +- ~~striked out~~ +- + +--- + +> Some quote + +> Quote with embedded list: +> +> - Hello +> - World + +--- + +- List with an embedded quote: + + > Tu quoque + + Wow rad stuff. + +- Second item in that list. + +--- + +Code with empty line: + + puts "wow" + + puts "amaze" + +--- + +Code in ordered list: + +1. Do you know the coolest codes? + + It's this: + + fire_missiles() + cancel() + + Great + +2. Also `fib` is pretty cool yeah diff --git a/tests/03.md.dump b/tests/03.md.dump new file mode 100644 index 0000000..e8b6b69 --- /dev/null +++ b/tests/03.md.dump @@ -0,0 +1,48 @@ +Inline markups: + + - ~~striked out~~ + - <http://example.com> + +---------- +> Some quote + +> Quote with embedded list: +>  +>  - Hello +>  - World + +---------- + - List with an embedded quote: + + > Tu quoque + + Wow rad stuff. + + - Second item in that list. + + +---------- +Code with empty line: + +   +  puts "wow"  +   +  puts "amaze"  +   + +---------- +Code in ordered list: + +1. Do you know the coolest codes? + + It's this: + +   +  fire_missiles()  +  cancel()  +   + + Great + +2. Also  fib  is pretty cool yeah + diff --git a/tests/deflist.md b/tests/deflist.md new file mode 100644 index 0000000..81aee19 --- /dev/null +++ b/tests/deflist.md @@ -0,0 +1,20 @@ +Term 1 + +: Definition 1 + +Term 2 with *inline markup* + +: Definition 2 + + { some code, part of Definition 2 } + + Third paragraph of definition 2. + +--- + +Term 1 + ~ Definition 1 + +Term 2 + ~ Definition 2a + ~ Definition 2b diff --git a/tests/deflist.md.dump b/tests/deflist.md.dump new file mode 100644 index 0000000..8089fda --- /dev/null +++ b/tests/deflist.md.dump @@ -0,0 +1,24 @@ +Term 1 + +: Definition 1 + +Term 2 with inline markup + +: Definition 2 + +   +  { some code, part of Definition 2 }  +   + + Third paragraph of definition 2. + +---------- +Term 1 + +: Definition 1 + +Term 2 + +: Definition 2a + +: Definition 2b diff --git a/tests/links.md b/tests/links.md new file mode 100644 index 0000000..153f959 --- /dev/null +++ b/tests/links.md @@ -0,0 +1,8 @@ +This is an "automatic link": . + +This is an [inline link](/url), and here's [one with +a title](http://fsf.org "click here for a good time!"). + +Let's talk about [foo][foosite] + +[foosite]: http://foo.com/ diff --git a/tests/links.md.dump b/tests/links.md.dump new file mode 100644 index 0000000..2862e9a --- /dev/null +++ b/tests/links.md.dump @@ -0,0 +1,10 @@ +This is an "automatic link": <https://jaspervdj.be>. + +This is an [inline link], and here's [one with +a title]. + +Let's talk about [foo] + +[inline link](/url) +[one with a title](http://fsf.org "click here for a good time!") +[foo](http://foo.com/) \ No newline at end of file diff --git a/tests/lists.md b/tests/lists.md new file mode 100644 index 0000000..d534704 --- /dev/null +++ b/tests/lists.md @@ -0,0 +1,13 @@ +- This is a nested list. + + * The nested items should have different list markers. + + * I mean, they can be the same, but it doesn't look nice. + + printf("Nested code block!\n") + + * Cool right? + + Definitely super cool + +- One final item diff --git a/tests/lists.md.dump b/tests/lists.md.dump new file mode 100644 index 0000000..1305289 --- /dev/null +++ b/tests/lists.md.dump @@ -0,0 +1,15 @@ + - This is a nested list. + +  * The nested items should have different list markers. + +  * I mean, they can be the same, but it doesn't look nice. + + printf("Nested code block!\n") + +  * Cool right? + + Definitely super cool + + + - One final item + diff --git a/tests/syntax.md b/tests/syntax.md new file mode 100644 index 0000000..f6c803d --- /dev/null +++ b/tests/syntax.md @@ -0,0 +1,14 @@ +--- +patat: + theme: + syntaxHighlighting: + decVal: [bold, onDullRed] +... + +Some simple code: + +```c +int main(int argc, char **argv) { + return 0; +} +``` diff --git a/tests/syntax.md.dump b/tests/syntax.md.dump new file mode 100644 index 0000000..eb4893f --- /dev/null +++ b/tests/syntax.md.dump @@ -0,0 +1,7 @@ +Some simple code: + +   +  int main(int argc, char **argv) {  +  return 0;  +  }  +   diff --git a/tests/tables.md b/tests/tables.md new file mode 100644 index 0000000..fe7d72e --- /dev/null +++ b/tests/tables.md @@ -0,0 +1,48 @@ +# Normal simple table + + Right Left Center Default +------- ------ ---------- ------- + 12 12 12 12 + 123 123 123 123 + 1 1 1 1 + +Table: Demonstration of simple table syntax. + + +# Headerless table + +------- ------ ---------- ------- + 12 12 12 12 + 123 123 123 123 + 1 1 1 1 +------- ------ ---------- ------- + +# Multiline + +------------------------------------------------------------- + Centered Default Right Left + Header Aligned Aligned Aligned +----------- ------- --------------- ------------------------- + First row 12.0 Example of a row that + spans multiple lines. + + Second row 5.0 Here's another one. Note + the blank line between + rows. +------------------------------------------------------------- + +Table: Here's the caption. It, too, may span +multiple lines. + +# Headerless multiline + +----------- ------- --------------- ------------------------- + First row 12.0 Example of a row that + spans multiple lines. + + Second row 5.0 Here's another one. Note + the blank line between + rows. +----------- ------- --------------- ------------------------- + +: Here's a multiline table without headers. diff --git a/tests/tables.md.dump b/tests/tables.md.dump new file mode 100644 index 0000000..0b0a93f --- /dev/null +++ b/tests/tables.md.dump @@ -0,0 +1,48 @@ +# Normal simple table + + Right Left Center Default + ----- ---- ------ ------- + 12 12 12 12  + 123 123 123 123  + 1 1 1 1  + + Table: Demonstration of simple table syntax. + +---------- +# Headerless table + + --- --- --- --- + 12 12 12 12 + 123 123 123 123 + 1 1 1 1  + --- --- --- --- + +---------- +# Multiline + + Centered Default Right Left  + Header Aligned Aligned Aligned  + -------- ------- ------- ------------------------ + First row 12.0 Example of a row that  + spans multiple lines.  +  + Second row 5.0 Here's another one. Note + the blank line between  + rows.  + + Table: Here's the caption. It, too, may span + multiple lines. + +---------- +# Headerless multiline + + ------ --- ---- ------------------------ + First row 12.0 Example of a row that  + spans multiple lines.  +  + Second row 5.0 Here's another one. Note + the blank line between  + rows.  + ------ --- ---- ------------------------ + + Table: Here's a multiline table without headers. diff --git a/tests/themes.md b/tests/themes.md new file mode 100644 index 0000000..6591ece --- /dev/null +++ b/tests/themes.md @@ -0,0 +1,11 @@ +--- +patat: + theme: + bulletListMarkers: '-+' + emph: [onVividRed, underline] +... + +- This is a simple list. + * With _nested_ items. + * One or two. +- The list theming is customized a bit. diff --git a/tests/themes.md.dump b/tests/themes.md.dump new file mode 100644 index 0000000..988214f --- /dev/null +++ b/tests/themes.md.dump @@ -0,0 +1,5 @@ + - This is a simple list. +  + With nested items. +  + One or two. + + - The list theming is customized a bit. diff --git a/tests/wrapping.md b/tests/wrapping.md new file mode 100644 index 0000000..15bc088 --- /dev/null +++ b/tests/wrapping.md @@ -0,0 +1,23 @@ +--- +patat: + wrap: true + columns: 40 +... + +This is a long +sentence over multiple +lines which can be +re-wrapped. + + +This is a super long sentence over a single line which should also be re-wrapped. + + + This is a table and tables should not be wrapped + ------- ------- ---------- ---------- ---------- + 1 2 3 4 5 + 6 7 8 9 10 + +- This is a list +- This list has a really long sentence in it which should also be wrapped with proper indentation +- Another item diff --git a/tests/wrapping.md.dump b/tests/wrapping.md.dump new file mode 100644 index 0000000..e23f9e3 --- /dev/null +++ b/tests/wrapping.md.dump @@ -0,0 +1,17 @@ +This is a long sentence over multiple +lines which can be re-wrapped. + +This is a super long sentence over a +single line which should also be +re-wrapped. + + This is a table and tables should not be wrapped + ------- ------- ---------- ---------- ---------- + 1 2 3 4 5  + 6 7 8 9 10  + + - This is a list + - This list has a really long sentence + in it which should also be wrapped + with proper indentation + - Another item